home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / ODE / obj_methods < prev    next >
Encoding:
Text File  |  1991-10-24  |  5.9 KB  |  235 lines
  1. \ This file defines the words used to define METHODS for a class.
  2. \ Methods are used to manipulate an objects instance variables.
  3. \
  4. \ Author: Phil Burk
  5. \ Copyright 1986 Phil Burk
  6. \
  7. \ MOD: PLB 11/29/86 Store CFAs in relocatable form for MAC
  8. \ MOD: PLB 2/10/87 Catch redeclared Methods!
  9. \ MOD: PLB 9/5/87 Add METHODS.OF and other tools.
  10. \ MOD: PLB 9/10/87 Attempt smart forget.
  11. \ MOD: PLB 11/16/87 Add CURRENT.OBJECT
  12. \ MOD: PLB 1/13/87 Use PFA for backlinking methods instead of NFA.
  13. \ MOD: PLB 9/13/88 Add [FORGET] to eliminate need for MRESET
  14. \ MOD: PLB 5/22/89 Add 0 ob-state ! to [FORGET]
  15. \ MOD: PLB 9/22/89 Fix stack checking for H4th.
  16. \ MOD: PLB 12/15/89 Add Defining Class for METHODS.OF
  17.  
  18. ANEW TASK-OBJ_METHODS
  19.  
  20. : MI++  ( -- index , allocate new method index )
  21.     mi-next @  ( current )
  22.     dup 1+ mi-next !   ( increment )
  23. ;
  24.  
  25. \ Method contents:
  26. \    CELL 0 = method index.
  27. \    CELL 1 = method back link (in relocatable form ).
  28.  
  29. \ Holds PFA of last defined method, relocatable.
  30. CREATE METHOD-LAST 0 ,
  31.  
  32. : (METHOD)  ( <name:> -- , declare method for later definition )
  33.     CREATE
  34.         here  ( for linking )
  35.         mi++ ,  ( cell1: set index )
  36.         method-last @ , ( cell2: back pointer )
  37.         use->rel method-last !   ( point to PFA of this method. )
  38.         immediate  ( make it immediate )
  39.     DOES>   @  ob.bind  ( bind message to object )
  40. ;
  41.  
  42. : METHOD  ( <name:>  -- , declare method if new )
  43.     >in @ ho.find.pfa
  44.     IF  @ mi-next <
  45.         IF word.dump ."  - method already declared." cr drop
  46.         ELSE  >in ! (method)
  47.         THEN
  48.     ELSE >in ! (method)
  49.     THEN
  50. ;
  51.  
  52. : OB.MIND@ ( <WORD> -- INDEX , return index )
  53.     ho.find.pfa NOT
  54.     IF
  55.         " OB.MIND@" " Method not declared!"
  56.         ER_FATAL  ER.REPORT
  57.     ELSE  ( save NFA of method for debugger )
  58.         dup pfa->nfa current-method !  @
  59.     THEN
  60. ;
  61.  
  62. \ Pairs checking for Method definitions.
  63. : OB.CHECK:M  ( flag -- , report pairing error if flag different )
  64.     dup ob-inside-:m @ =
  65.     IF  not ob-inside-:m !
  66.     ELSE drop " OB.CHECK:M" " Missing :M or ;M in class definition!"
  67.         er_fatal er.report
  68.     THEN
  69. ;
  70.  
  71. \ :M is one of the most complicated words in the system.
  72. \ It generates a headerless secondary with some object stack manipulations
  73. \ at the beginning and end.
  74. \ It will have to be hand tweaked for each FORTH because of
  75. \ differences in the compilers.
  76.  
  77. : :M ( <method> -- , COMPILE A METHOD FOR A CLASS )
  78.     false ob.check:m
  79.     ob.mind@  dup ob-current-mind !
  80.     here ( -- mi cfa , save cfa )
  81. \
  82. \ Convert CFA to relocatable token for systems that need it.
  83.     use->rel
  84. \
  85. \ Calculate offset into cfa table for this method.
  86.     swap cell*                ( -- cfa moffset )
  87. \ Store CFA in methods table.
  88.     ob-current-class @    ob_cfas +   ( -- base_cfas ) + !
  89. \
  90. \ Start compiling in normal fashion.
  91.     stack.mark          ( save stack position to check for leftovers )
  92.     !csp   ( for H4th )
  93. \
  94.     [compile] ]
  95. ;
  96.  
  97.  
  98. #HOST_MAC_H4th .IF
  99. : ;M ( -- , Terminate method definition )
  100.     true ob.check:m
  101.     current-method off
  102.     -1 ob-current-mind !
  103.     [compile] ;     ( Go back to interpretation mode , checks stack )
  104. ;  immediate
  105. .THEN
  106.  
  107. #HOST_AMIGA_JFORTH .IF
  108. : <;M> ( -- , Terminate method definition )
  109.     true ob.check:m
  110.     stack.check
  111.     current-method off
  112.     -1 ob-current-mind !
  113.     compile exit    ( Leave method )
  114.     [compile] [     ( Go back to interpretation mode )
  115. ;  immediate
  116. \ Use deferred ;M for Locals and Debugger.
  117.     ' <;M> is ;M
  118. .THEN
  119.  
  120. 0 MI-NEXT !  ( reset method counter )
  121. METHOD INIT:  ( INIT: MUST have method index = 0 !!! )
  122.  
  123. \ This is handy for inside Forth words called from a method.
  124. : CURRENT.OBJECT ( -- object )
  125.     os.copy use->rel
  126. ;
  127.  
  128. create MRESET-WARN true ,
  129.  
  130. : MRESET ( <method> -- )
  131.     32 word
  132.     mreset-warn @
  133.     IF  ." MRESET "  $type
  134.         ."  is no longer needed!" cr
  135.     ELSE drop
  136.     THEN
  137. ;
  138.  
  139. : [FORGET] ( -- , reset method index )
  140.     [forget]
  141.     method-last @ rel->use  ( get last method )
  142.     BEGIN dup here > ( is it forgotten )
  143.     WHILE ( -- method_pfa )
  144.         cell+ @ if.rel->use
  145.     REPEAT
  146.     dup if.use->rel method-last !  ( set pointer to last )
  147.     @ 1+ mi-next !    ( reset index so CFA tables don't grow)
  148.     0 ob-state !   ( reset state to avoid :CLASS warnings )
  149. ;
  150.  
  151. : METHOD.LINK ( method_PFA -- index previous_pfa )
  152.     dup @ swap cell+ @ ?dup
  153.     IF rel->use
  154.     ELSE 0  ( for the Mac )
  155.     THEN
  156. ;
  157.  
  158. : (.METHOD)  ( method_pfa method_index -- , print it )
  159.     4 .r space pfa->nfa id.
  160. ;
  161.  
  162. : ALL.METHODS ( -- list all methods )
  163.     cr method-last @ rel->use
  164.     BEGIN dup
  165.     WHILE dup method.link -rot
  166.         (.method) cr ?pause
  167.     REPEAT drop
  168. ;
  169.  
  170. variable OB-SCRATCH
  171.  
  172. : ?DEFINING.CLASS ( method_index pfa_class -- pfa_class' )
  173. \ Scan backwards in Class list to find first occurrence of method.
  174. \ Do this by checking superclass for bad method, index overrange,
  175. \   or 0 pointer.
  176.     2dup method@ >r  ( cfa to match with )
  177. \ Give up if 0 super link.
  178.     BEGIN dup ..@ ob_super if.rel->use dup ob-scratch ! ( non-zero? )
  179.         IF  ( super class = 0 for object class )
  180. \ Give up if method count of superclass too low.
  181.             ob-scratch @ ..@ ob_#methods 2 pick >
  182. \ Give up if method CFA doesn't match
  183.             IF  over ob-scratch @ method@ r@ =
  184.                 IF drop ob-scratch @ ( use super ) false
  185.                 ELSE true
  186.                 THEN
  187.             ELSE true
  188.             THEN
  189.         ELSE true
  190.         THEN
  191.     UNTIL rdrop nip
  192. ;
  193.  
  194. : METHODS.OF ( <class> -- , list valid methods for class )
  195.     cr ho.find.pfa
  196.     IF  dup ob.check.class
  197.         >r
  198. \ Start with last method defined, scan all methods,
  199. \ print it if its method cfa is not the OB.BAD.METHOD cfa.
  200.         method-last @ rel->use
  201.         BEGIN dup  ?pause
  202. \ Link to next method header in dictionary.
  203.         WHILE dup method.link -rot ( -- prev pfa i )
  204. \ Check to see if class method table is big enough.
  205.             dup r@ ..@ ob_#methods <  ( -- prev pfa i f )
  206.             IF  ( prev pfa index )
  207. \ Compare CFA of method.
  208.                 dup r@ method@ 'c ob.bad.method -
  209.                 IF  tuck (.method) 4 spaces
  210.                     r@ ?defining.class pfa->nfa
  211.                     BL 20 emit-to-column id. cr
  212.                 ELSE 2drop
  213.                 THEN
  214.             ELSE 2drop
  215.             THEN
  216.         REPEAT drop
  217.         rdrop
  218.     ELSE " METHODS.OF" " Not a class!"
  219.         er_fatal er.report
  220.     THEN
  221. ;
  222.  
  223. \ Required Initialization
  224. : OB.INIT ( -- )
  225.     os.sp!   ( set object stack pointers )
  226.     0 ob-state !
  227.     0 ob-current-class !
  228.     0 ob-self-cfas !
  229.     0 ob-super-cfas !
  230.     0 ob-dooper-cfas !
  231.     true ob-if-check-bind !
  232. ;
  233. : OB.TERM ( -- )
  234. ;
  235.